home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 May / Macworld (1998-05).dmg / Serious Demos / TeamWave 3.0 / TeamWave Workplace / TeamWave Workplace.rsrc / TEXT_9_palette.txt < prev    next >
Text File  |  1998-02-13  |  7KB  |  223 lines
  1. # palette.tcl --
  2. #
  3. # This file contains procedures that change the color palette used
  4. # by Tk.
  5. #
  6. # SCCS: @(#) palette.tcl 1.11 97/06/23 20:35:44
  7. #
  8. # Copyright (c) 1995-1997 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14. # tk_setPalette --
  15. # Changes the default color scheme for a Tk application by setting
  16. # default colors in the option database and by modifying all of the
  17. # color options for existing widgets that have the default value.
  18. #
  19. # Arguments:
  20. # The arguments consist of either a single color name, which
  21. # will be used as the new background color (all other colors will
  22. # be computed from this) or an even number of values consisting of
  23. # option names and values.  The name for an option is the one used
  24. # for the option database, such as activeForeground, not -activeforeground.
  25.  
  26. proc tk_setPalette {args} {
  27.     global tkPalette
  28.  
  29.     # Create an array that has the complete new palette.  If some colors
  30.     # aren't specified, compute them from other colors that are specified.
  31.  
  32.     if {[llength $args] == 1} {
  33.     set new(background) [lindex $args 0]
  34.     } else {
  35.     array set new $args
  36.     }
  37.     if ![info exists new(background)] {
  38.     error "must specify a background color"
  39.     }
  40.     if ![info exists new(foreground)] {
  41.     set new(foreground) black
  42.     }
  43.     set bg [winfo rgb . $new(background)]
  44.     set fg [winfo rgb . $new(foreground)]
  45.     set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \
  46.         [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]]
  47.     foreach i {activeForeground insertBackground selectForeground \
  48.         highlightColor} {
  49.     if ![info exists new($i)] {
  50.         set new($i) $new(foreground)
  51.     }
  52.     }
  53.     if ![info exists new(disabledForeground)] {
  54.     set new(disabledForeground) [format #%02x%02x%02x \
  55.         [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \
  56.         [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \
  57.         [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]]
  58.     }
  59.     if ![info exists new(highlightBackground)] {
  60.     set new(highlightBackground) $new(background)
  61.     }
  62.     if ![info exists new(activeBackground)] {
  63.     # Pick a default active background that islighter than the
  64.     # normal background.  To do this, round each color component
  65.     # up by 15% or 1/3 of the way to full white, whichever is
  66.     # greater.
  67.  
  68.     foreach i {0 1 2} {
  69.         set light($i) [expr [lindex $bg $i]/256]
  70.         set inc1 [expr ($light($i)*15)/100]
  71.         set inc2 [expr (255-$light($i))/3]
  72.         if {$inc1 > $inc2} {
  73.         incr light($i) $inc1
  74.         } else {
  75.         incr light($i) $inc2
  76.         }
  77.         if {$light($i) > 255} {
  78.         set light($i) 255
  79.         }
  80.     }
  81.     set new(activeBackground) [format #%02x%02x%02x $light(0) \
  82.         $light(1) $light(2)]
  83.     }
  84.     if ![info exists new(selectBackground)] {
  85.     set new(selectBackground) $darkerBg
  86.     }
  87.     if ![info exists new(troughColor)] {
  88.     set new(troughColor) $darkerBg
  89.     }
  90.     if ![info exists new(selectColor)] {
  91.     set new(selectColor) #b03060
  92.     }
  93.  
  94.     # let's make one of each of the widgets so we know what the 
  95.     # defaults are currently for this platform.
  96.     toplevel .___tk_set_palette
  97.     wm withdraw .___tk_set_palette
  98.     foreach q {button canvas checkbutton entry frame label listbox menubutton menu message \
  99.          radiobutton scale scrollbar text} {
  100.     $q .___tk_set_palette.$q
  101.     }
  102.  
  103.     # Walk the widget hierarchy, recoloring all existing windows.
  104.     # The option database must be set according to what we do here, 
  105.     # but it breaks things if we set things in the database while 
  106.     # we are changing colors...so, tkRecolorTree now returns the
  107.     # option database changes that need to be made, and they
  108.     # need to be evalled here to take effect.
  109.     # We have to walk the whole widget tree instead of just 
  110.     # relying on the widgets we've created above to do the work
  111.     # because different extensions may provide other kinds
  112.     # of widgets that we don't currently know about, so we'll
  113.     # walk the whole hierarchy just in case.
  114.  
  115.     eval [tkRecolorTree . new]
  116.  
  117.     catch {destroy .___tk_set_palette}
  118.  
  119.     # Change the option database so that future windows will get the
  120.     # same colors.
  121.  
  122.     foreach option [array names new] {
  123.     option add *$option $new($option) widgetDefault
  124.     }
  125.  
  126.     # Save the options in the global variable tkPalette, for use the
  127.     # next time we change the options.
  128.  
  129.     array set tkPalette [array get new]
  130. }
  131.  
  132. # tkRecolorTree --
  133. # This procedure changes the colors in a window and all of its
  134. # descendants, according to information provided by the colors
  135. # argument. This looks at the defaults provided by the option 
  136. # database, if it exists, and if not, then it looks at the default
  137. # value of the widget itself.
  138. #
  139. # Arguments:
  140. # w -            The name of a window.  This window and all its
  141. #            descendants are recolored.
  142. # colors -        The name of an array variable in the caller,
  143. #            which contains color information.  Each element
  144. #            is named after a widget configuration option, and
  145. #            each value is the value for that option.
  146.  
  147. proc tkRecolorTree {w colors} {
  148.     global tkPalette
  149.     upvar $colors c
  150.     set result {}
  151.     foreach dbOption [array names c] {
  152.     set option -[string tolower $dbOption]
  153.     if {![catch {$w config $option} value]} {
  154.         # if the option database has a preference for this
  155.         # dbOption, then use it, otherwise use the defaults
  156.         # for the widget.
  157.         set defaultcolor [option get $w $dbOption widgetDefault]
  158.         if {[string match {} $defaultcolor]} {
  159.         set defaultcolor [winfo rgb . [lindex $value 3]]
  160.         } else {
  161.         set defaultcolor [winfo rgb . $defaultcolor]
  162.         }
  163.         set chosencolor [winfo rgb . [lindex $value 4]]
  164.         if {[string match $defaultcolor $chosencolor]} {
  165.         # Change the option database so that future windows will get
  166.         # the same colors.
  167.         append result ";\noption add [list \
  168.             *[winfo class $w].$dbOption $c($dbOption) 60]"
  169.         $w configure $option $c($dbOption)
  170.         }
  171.     }
  172.     }
  173.     foreach child [winfo children $w] {
  174.     append result ";\n[tkRecolorTree $child c]"
  175.     }
  176.     return $result
  177. }
  178.  
  179. # tkDarken --
  180. # Given a color name, computes a new color value that darkens (or
  181. # brightens) the given color by a given percent.
  182. #
  183. # Arguments:
  184. # color -    Name of starting color.
  185. # perecent -    Integer telling how much to brighten or darken as a
  186. #        percent: 50 means darken by 50%, 110 means brighten
  187. #        by 10%.
  188.  
  189. proc tkDarken {color percent} {
  190.     set l [winfo rgb . $color]
  191.     set red [expr [lindex $l 0]/256]
  192.     set green [expr [lindex $l 1]/256]
  193.     set blue [expr [lindex $l 2]/256]
  194.     set red [expr ($red*$percent)/100]
  195.     if {$red > 255} {
  196.     set red 255
  197.     }
  198.     set green [expr ($green*$percent)/100]
  199.     if {$green > 255} {
  200.     set green 255
  201.     }
  202.     set blue [expr ($blue*$percent)/100]
  203.     if {$blue > 255} {
  204.     set blue 255
  205.     }
  206.     format #%02x%02x%02x $red $green $blue
  207. }
  208.  
  209. # tk_bisque --
  210. # Reset the Tk color palette to the old "bisque" colors.
  211. #
  212. # Arguments:
  213. # None.
  214.  
  215. proc tk_bisque {} {
  216.     tk_setPalette activeBackground #e6ceb1 activeForeground black \
  217.         background #ffe4c4 disabledForeground #b0b0b0 foreground black \
  218.         highlightBackground #ffe4c4 highlightColor black \
  219.         insertBackground black selectColor #b03060 \
  220.         selectBackground #e6ceb1 selectForeground black \
  221.         troughColor #cdb79e
  222. }
  223.